COMMENT ⊗   VALID 00017 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Fibonacci
C00003 00003	 EQUAL
C00004 00004	 Match
C00006 00005	 Y
C00007 00006	 QY
C00008 00007	 Bomb Test
C00010 00008	 Lock Test
C00012 00009	 Builtin Lock Test
C00013 00010	 Function computation test
C00014 00011	 Pipeline Experiment
C00015 00012	 Branched Pipeline Test
C00016 00013	 Grid Test
C00017 00014	 Circular-list Factorial
C00019 00015	 Bank Balance
C00020 00016	 Monte Carlo Approximation to π
C00021 00017	 Add up Leaves
C00025 ENDMK
C⊗;
;;; Fibonacci

(setq cutoff 5)

(m-defun fib (n depth)
	 (cond ((zerop n) 1)
	       ((= n 1) 1)
	       (t
		(qlet (< depth cutoff)
		      ((x (fib (1- n) (1+ depth)))
		       (y (fib (- n 2) (1+ depth))))
		      (+ x y)))))

;;; EQUAL

(m-defun m-equal (x y)
	 (qcatch 'm-equal
		 (labels ((equal
			   (lambda (x y)
				   (cond ((eql x y))
					 ((or (atom x)
					      (atom y))
					  (throw 'm-equal ()))
					 (t
					  (funcall
					   (qlambda t ()
						    (equal (car x)(car y))))
					  (funcall 
					   (qlambda t ()
						    (equal (cdr x)(cdr y))))
					  t)))))
			 (equal x y))))

;;; Match

(setq m-p t)

(m-defun match (x y)
	 (qcatch 'match 
		 (match1 x y ())))

(m-defun match1 (x y alist)
     (cond ((eq x y)
	    (setq result alist)
	    (throw 'match t))
	   ((null x) ())
	   ((null y) ())
	   ((eq (car x) (car y)) (match1 (cdr x)(cdr y) alist))
	   ((atom (car x)) ())
	   ((eq (caar x) '?)
	    (match1 (cdr x) (cdr y) (cons (cons (car x) (car y)) alist)))
	   ((eq (caar x) '*) 
	    (do ((l y (cdr l))
		 (a () (cons (car l) a)))
		((null l)
 		 (funcall 
		  (qlambda m-p ()
			   (match1 (cdr x) ()
				   (cons (cons (car x)
					       (reverse a))
					 alist))))
		 ())
 		(funcall 
		 (qlambda m-p ()
			  (match1 (cdr x) l
				  (cons (cons (car x) 
					      (reverse a))
					alist))))
		))))

(m-defun test-match ()
	 (match '((* x) a (* y))
		'(1 2 3 a 4 5 6)))
;;; Y

(m-defun Y (f)
	 (let ((h (lambda (g)
			  (f (lambda (x) 
				     (funcall (g g) x))))))  
	      (lambda (x) (funcall (h h) x))))

(m-defun test-y ()
	 (setq l '(1 2 3 4 5 6 7 8 9 10))
	 (let ((len 
		(y
		 (lambda (f)
			 (lambda (x)
				 (cond ((null x) 0)
				       (t (1+ (f (cdr x))))))))))
	      (len l)))

;;; QY

(m-defun QY (f)
	 (let ((tag (ncons ()))
	       (h (lambda (g)
			  (f (qlambda 'eager (x) 
				      (funcall (g g) x))))))  
	      (qlambda 'eager (x) 
		       (catch tag
			      (funcall (h h) x)))))

(m-defun test-qy ()
	 (setq lll '(1 2 3))
	 (let ((len 
		(qy
		 (lambda (f)
			 (lambda (x)
				 (cond ((null x) 0)
				       (t 
					(1+ (f (cdr x))))))))))
	      (len lll)))

;;; Bomb Test

(m-defun test-bomb ()
	 (let ((bombs ()))
	      (let ((bomb-handler
		     (qlambda t (type id message)
			      (cond ((eq type 'bomb)
				     (print `(bomb for ,id))
				     (setq bombs 
					   (cons (cons id message) bombs)))
				    ((eq type 'kill)
				     (print `(kill for ,id))
				     (funcall (qlambda t ()
						       (funcall
							(cdr (assq id bombs)))))
				     t)))))
		   (qlet 'eager
			 ((x (catch 'quit (tester bomb-handler 'a)))
			  (y (catch 'quit (tester bomb-handler 'b))))
			 (funcall (qlambda t ()
					   (do ((i 10. (1- i)))
					       ((= i 0)
						(print `(killing a))
						(bomb-handler 'kill 'a ()))
					       (print `(countdown a ,i)))
					   (do ((i 10. (1- i)))
					       ((= i 0)
						(print `(killing b))
						(bomb-handler 'kill 'b ()))
					       (print `(countdown b ,i)))))
			 (print (list 'done x y))))))

(m-defun tester (bomb-handler letter)
	 (bomb-handler 'bomb letter
		       (qlambda t () (throw 'quit letter)))
	 (do ()(()) (print letter)))

;;; Lock Test

(defmacro get-lock-baz ()
	  '(catch 'foo
		  (progn 
		   (lock 
		    (qlambda t (res)(throw 'foo res)))
		   (suspend-process *self*))))

(m-defun test-funny-lock ()
	 (let ((lock
		(qlambda t (returner)
			 (let ((newtag (ncons ())))
			      (catch newtag 
				     (let ((res (qlambda t () (print 'doing-throw) (throw newtag t))))
					  (progn (returner res)
						 (print 'here)
						 (suspend-process *self*))))))))
	      (qlet t 
		    ((x (let ((owned-lock (get-lock-baz)))
			     (do ((i 10 (1- i)))
				 ((= i 0)
				  (owned-lock) 7)
				 (print 'right))))
		     (y (let ((owned-lock (get-lock-baz)))
			     (do ((i 10 (1- i)))
				 ((= i 0)
				  (owned-lock) 8)
				 (print 'wrong)))))
		    (list x y))))
	 
;;; Builtin Lock Test

(m-defun test-builtin-lock ()
	 (let ((lock (create-lock)))
	      (qlet t ((x
			(let ((owned-lock (get-lock lock)))
			     (do ((i 10 (1- i)))
				 ((= i 0)
				  (release-lock lock) 7)
				 (print 'right))))
		       (y (let ((owned-lock (get-lock lock)))
			       (do ((i 10 (1- i)))
				   ((= i 0)
				    (release-lock lock) 8)
				   (print 'wrong))))
		       (z (let ((owned-lock (get-lock lock)))
			       (do ((i 10 (1- i)))
				   ((= i 0)
				    (release-lock lock) 9)
				   (print 'so-what)))))
		    (list x y z))))
	 
	 
;;; Function computation test

(m-defun test-fun-comp ()
	 (let ((f (lambda (x)(lambda (y)(+ x y)))))
	      ((f 2) 3)))
;;; Pipeline Experiment

(m-defun horner-stream ()
 (pipeline foo ((q 0))
  ((stage (x) x (+ (* 5 x) 4))
   (stage (x v) x (+ (* v x) 3))
   (stage (x v) x (+ (* v x) (global-ref q)))
   (stage (x v) 
	  (print (+ (* v x) 1))
	  (setf (global-ref q)(1+ (global-ref q)))))
  (foo 1)(foo 2)(foo 3)(foo 4)
  (foo 5)(foo 6)(foo 7)(foo 8)(foo 9)(foo 10)))

(m-defun test-pipeline ()
	 (horner-stream))

;;; Branched Pipeline Test

(m-defun branch-test ()
  (pipeline foo ()
	    ((stage (x) x (* x x))
	     (defstage bar1 (x v) (go-stage bar2 x (times x x x)))
	     (defstage bar2 (x v) (print (list 'odd x v)))
	     (defstage foo1 (x v) (go-stage foo2 x (times x x)))
	     (defstage foo2 (x v) (print (list 'even x v)))
	     (stage (x v) (cond ((evenp x)
				 (go-stage foo1 x v))
				(t 
				 (go-stage bar1 x v)))))
	    (foo 1)(foo 2)(foo 3)(foo 4)))

;;; Grid Test

(m-defun test-grid ()
	 (grid *grid* (2 2) 
	       (((0 0) (qlambda t (x n m)
				(print (list 'in '(0 0)))
				(print (list x n m))
				(call-grid *grid* (0 1) (1+ x) 0 0)
				t))
		((0 1) (qlambda t (x n m)
				(print (list 'in '(0 1)))
				(print (list x n m))
				(call-grid *grid* (1 0) (1+ x) 1 0)
				t))
		((1 0) (qlambda t (x n m)
				(print (list 'in '(1 0)))
				(print (list x n m))
				(call-grid *grid* (1 1) (1+ x) 1 1)
				t))
		((1 1) (qlambda t (x n m)
				(print (list 'in '(1 1)))
				(print (list x n m))
				t)))
	       (call-grid *grid* (0 0) 0 -1 -1)))

;;; Circular-list Factorial

(defmacro element (current-list)
	  `(let ((L ,current-list))
		(qlambda t (n m)
			 (cond ((zerop n) m)
			       (t (funcall (cadr L) (1- n) (* m n)))))))

(m-defun test-circ ()
	 (let ((l (list () () () () () ())))
	      (setf (nthcdr 6 l) l)
	      (setf (nth 0 l)
		    (element (nthcdr 0 l)))
	      (setf (nth 1 l)
		    (element (nthcdr 1 l)))
	      (setf (nth 2 l)
		    (element (nthcdr 2 l)))
	      (setf (nth 3 l)
		    (element (nthcdr 3 l)))
	      (setf (nth 4 l)
		    (element (nthcdr 4 l)))
	      (setf (nth 5 l)
		    (element (nthcdr 5 l)))
	      (wait (funcall (car l) 5 1))))

;;; Bank Balance

(m-defun make-account (balance)
	 (labels 
	  ((withdraw (lambda (amount)
			     (cond ((lessp balance amount)
				    'insufficient-funds)
				   (t
				    (setq balance
					  (difference balance amount))
				    balance))))
	   (deposit (lambda (amount)
			    (setq balance (plus balance amount))))
	   (dispatch (lambda (mess)
			     (cond ((eq mess 'deposit)
				    deposit)
				   ((eq mess 'withdraw)
				    withdraw)
				   (t 'error)))))
	  dispatch))

(m-defun test-bank()
	 (setq acc (make-account 100))
	 (print ((acc 'deposit) 50))
	 (print ((acc 'withdraw) 25)))

;;; Monte Carlo Approximation to π

(m-defun approx-pi (trials)
  (labels ((rand
	    (let ((random 21.))
		 (lambda ()
			 (setq random (remainder (* random 17.) 251.)))))
	   (monte-carlo
	    (lambda (trials experiment)
		    (do ((tr trials (1- tr))
			 (passed 0 passed))
			((zerop tr)
			 (//$ (float passed)(float trials)))
			(cond ((experiment)
			       (setq passed (1+ passed)))))))
	   (cesaro-test
	    (lambda () (= (gcd (rand)(rand)) 1))))
	  (sqrt (//$ 6.0 (monte-carlo trials cesaro-test)))))

;;; Add up Leaves

(m-defun add-up (l)
	 ((lambda (adder)
		  (setq *sum* 0)
 		  (qcatch 'end
			  (progn (funcall (qlambda t () (add-all adder (car l))))
				 (funcall (qlambda t () (add-all adder (cdr l))))
				 t))
		  *sum*)
		  (qlambda t (x)
			   (setq *sum* (plus *sum* x)))))
(m-defun add-all (f x)
	 (cond ((null x) t)
	       ((numberp x)
		((lambda (y)()) (f x)))
	       (t (funcall (qlambda t () (add-all f (car x))))
		  (funcall (qlambda t () (add-all f (cdr x))))
		  t)))

;;; *********************

(m-defun add-up3 (l)
	 ((lambda (adder)
		  (setq *sum* 0)
 		  (qcatch 'end
			  (progn (funcall (qlambda t () (add-all3 adder l)))
				 t))
		  *sum*)
		  (qlambda t (x)
			   (setq *sum* (plus *sum* x)))))
(m-defun add-all3 (f x)
	 (cond ((null x) t)
	       ((numberp x)
		((lambda (y) y)(f x)))
	       (t (funcall (qlambda t () (add-all3 f (car x))))
		  (add-all3 f (cdr x)))))

;;; *********************

(m-defun add-up2 (x)
	 (cond ((null x) 0)
	       ((numberp x) x)
	       (t ((qlambda t (m n)
			    (+ m n))
		   (add-up2 (car x))
		   (add-up2 (cdr x))))))

;;; *********************

(m-defun add-up5 (x)
	 (cond ((null x) 0)
	       ((numberp x) x)
	       (t ((qlambda 'eager (m n)
			    (+ m n))
		   (add-up5 (car x))
		   (add-up5 (cdr x))))))

;;; *********************

(m-defun add-up4 (l)
	 ((lambda (adder)
		  (setq *sum* 0)
 		  (qcatch 'end
			  (progn (funcall (qlambda t () (add-all4 adder l)))
				 t))
		  *sum*)
		  (qlambda t (x)
			   (setq *sum* (plus *sum* x)))))
(m-defun add-all4 (f x)
	 (cond ((null x) t)
	       (t ((lambda (ncar ncdr)
			   (cond ((and ncar ncdr)
				  (f (car x))
				  ((lambda (y)
					   y)
				   (f (cdr x))))
				 (ncar
				  ((lambda (y)
					   y)
				   (f (car x)))
				  (add-all4 f (cdr x)))
				 (ncdr
				  ((lambda (y)
					   y)
				   (f (cdr x)))
				  (add-all4 f (car x)))
				 (t (funcall (qlambda t () (add-all4 f (car x))))
				    (add-all4 f (cdr x)))))
		   (numberp (car x))(numberp (cdr x))))))